home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol160 / alphaper.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1986-12-16  |  5.3 KB  |  179 lines
  1. 90  WIDTH "scrn:", 80
  2. 95  SCREEN 0,1,0,0
  3. 100  TITLE$ = "Alphabetic Person Name Listing"
  4. 105  TITLE$ = TITLE$ + " ON DISPLAY"
  5. 110  VERSION$ = "Version 3.1"
  6. 115  COPY1$ = "Copyright (c) 1983, 1984, 1985, by:"
  7. 120  COPY2$ = "Melvin O. Duke"
  8. 125  PRICE$ = "$35"
  9. 130  ADDR1$ = "Melvin O. Duke"
  10. 135  ADDR2$ = "P. O. Box 20836"
  11. 140  ADDR3$ = "San Jose, CA  95160"
  12. 145  REM Dimension Statements go here
  13. 150  DIM IDX$(500), WHERE(500)
  14. 170  REM Produce the first screen
  15. 175  KEY OFF : CLS
  16. 180  REM Draw the outer double box
  17. 185  R1 = 1 : C1 = 1 : R2 = 24 : C2 = 79 : GOSUB 400
  18. 190  REM Find the title location
  19. 195  TITLE.POS = 40 - INT(LEN(TITLE$)/2)
  20. 200  REM Draw the title box
  21. 205  R1=3:C1=TITLE.POS-2:R2=6:C2=TITLE.POS+LEN(TITLE$)+1:GOSUB 600
  22. 210  REM Print the title
  23. 215  LOCATE 4,TITLE.POS : PRINT TITLE$
  24. 220  LOCATE 5,40-INT(LEN(VERSION$)/2) :  PRINT VERSION$;
  25. 225  REM Draw the Contribution box
  26. 230  R1 = 8 : C1 = 19 : R2 = 17 : C2 = 62 : GOSUB 400
  27. 235  REM Request the Contribution
  28. 240  LOCATE 9,23 : PRINT "If you are using these programs, and"
  29. 245  LOCATE 10,21 : PRINT "finding them of value, your contribution"
  30. 250  LOCATE 11,23 : PRINT "("+PRICE$+" suggested) will be anticipated."
  31. 255  REM Draw the Mailing Label
  32. 260  R1 = 12 : C1 = 28 : R2 = 16 : C2 = 52 : GOSUB 600
  33. 265  REM Print the Name and Address
  34. 270  LOCATE 13,40-INT(LEN(ADDR1$)/2) :  PRINT ADDR1$;
  35. 275  LOCATE 14,40-INT(LEN(ADDR2$)/2) :  PRINT ADDR2$;
  36. 280  LOCATE 15,40-INT(LEN(ADDR3$)/2) :  PRINT ADDR3$;
  37. 285  REM Draw the Copyright box
  38. 290  R1 = 19 : C1 = 21 : R2 = 22 : C2 = 59 : GOSUB 400
  39. 295  REM Print the Copyright
  40. 300  LOCATE 20,40-INT(LEN(COPY1$)/2) :  PRINT COPY1$;
  41. 305  LOCATE 21,40-INT(LEN(COPY2$)/2) :  PRINT COPY2$;
  42. 310  GOTO 740
  43. 400  REM subroutine to print a double box
  44. 405  COLOR 5
  45. 410  FOR I = R1 + 1 TO R2 - 1
  46. 420   LOCATE I, C1 : PRINT CHR$(186);
  47. 430   LOCATE I, C2 : PRINT CHR$(186);
  48. 440  NEXT I
  49. 450  FOR J = C1 + 1 TO C2 - 1
  50. 460   LOCATE R1, J : PRINT CHR$(205);
  51. 470   LOCATE R2, J : PRINT CHR$(205);
  52. 480  NEXT J
  53. 490   LOCATE R1, C1 : PRINT CHR$(201);
  54. 500   LOCATE R1, C2 : PRINT CHR$(187);
  55. 510   LOCATE R2, C1 : PRINT CHR$(200);
  56. 520   LOCATE R2, C2 : PRINT CHR$(188);
  57. 525  COLOR 7
  58. 530  RETURN
  59. 600  REM subroutine to print a single box
  60. 605  COLOR 3
  61. 610  FOR I = R1 + 1 TO R2 - 1
  62. 620   LOCATE I, C1 : PRINT CHR$(179);
  63. 630   LOCATE I, C2 : PRINT CHR$(179);
  64. 640  NEXT I
  65. 650  FOR J = C1 + 1 TO C2 - 1
  66. 660   LOCATE R1, J : PRINT CHR$(196);
  67. 670   LOCATE R2, J : PRINT CHR$(196);
  68. 680  NEXT J
  69. 690   LOCATE R1, C1 : PRINT CHR$(218);
  70. 700   LOCATE R1, C2 : PRINT CHR$(191);
  71. 710   LOCATE R2, C1 : PRINT CHR$(192);
  72. 720   LOCATE R2, C2 : PRINT CHR$(217);
  73. 725  COLOR 7
  74. 730  RETURN
  75. 740  REM ask user to press a key to continue
  76. 750  LOCATE 25,1
  77. 760  PRINT "Have Data Diskette(s) in Place, then Press any key to continue.";
  78. 770  K$ = INKEY$ : IF K$ = "" THEN 770
  79. 780  CLS
  80. 1000  REM Alphabetic Person Name Listing.
  81. 1010  REM By:  Melvin O. Duke.  Last Updated:  01 August 1985.
  82. 1020  OPEN "a:persfile" AS #1 LEN = 256
  83. 1030  FIELD 1, 5 AS F1$, 20 AS F2$, 30 AS F3$, 2 AS F4$, 5 AS F5$, 5 AS F6$, 5 AS F7$, 11 AS F8$, 18 AS F9$, 16 AS F10$, 16 AS F11$, 11 AS F12$, 18 AS F13$, 16 AS F14$, 16 AS F15$, 11 AS F16$, 18 AS F17$, 16 AS F18$, 16 AS F19$
  84. 1040  CLS
  85. 1050  REM Read all records, and print the actual ones
  86. 1060  N.ACT = 1
  87. 1070  FOR I = 1 TO 500
  88. 1080  GET #1, I
  89. 1090  LOCATE 23,1 : PRINT "Processing Record:";I,"Freespace:";FRE(0)
  90. 1100  REM Extract Information from the File
  91. 1110   WHERE(N.ACT) = CVS(F1$)
  92. 1120   IF WHERE(N.ACT) < 1 THEN 1410
  93. 1130   T2$ = F2$  'Surname
  94. 1140   REM Right-trim t2$
  95. 1150   FOR J = 1 TO LEN(F2$)-1
  96. 1160    IF RIGHT$(T2$,1)=" "THEN T2$=LEFT$(T2$,LEN(T2$)-1) ELSE J=LEN(F2$)-1
  97. 1170   NEXT J
  98. 1180   T3$ = F3$  'Given Names
  99. 1190   REM Right-trim t3$
  100. 1200   FOR J = 1 TO LEN(F3$)-1
  101. 1210    IF RIGHT$(T3$,1)=" "THEN T3$=LEFT$(T3$,LEN(T3$)-1) ELSE J=LEN(F3$)-1
  102. 1220   NEXT J
  103. 1230   T8$ = F8$  'Birthdate
  104. 1240   REM convert to yyyymmdd
  105. 1250   TEMP$ = RIGHT$(T8$,4)
  106. 1260   IF MID$(T8$,4,3)="Jan" THEN TEMP$=TEMP$+"01"
  107. 1270   IF MID$(T8$,4,3)="Feb" THEN TEMP$=TEMP$+"02"
  108. 1280   IF MID$(T8$,4,3)="Mar" THEN TEMP$=TEMP$+"03"
  109. 1290   IF MID$(T8$,4,3)="Apr" THEN TEMP$=TEMP$+"04"
  110. 1300   IF MID$(T8$,4,3)="May" THEN TEMP$=TEMP$+"05"
  111. 1310   IF MID$(T8$,4,3)="Jun" THEN TEMP$=TEMP$+"06"
  112. 1320   IF MID$(T8$,4,3)="Jul" THEN TEMP$=TEMP$+"07"
  113. 1330   IF MID$(T8$,4,3)="Aug" THEN TEMP$=TEMP$+"08"
  114. 1340   IF MID$(T8$,4,3)="Sep" THEN TEMP$=TEMP$+"09"
  115. 1350   IF MID$(T8$,4,3)="Oct" THEN TEMP$=TEMP$+"10"
  116. 1360   IF MID$(T8$,4,3)="Nov" THEN TEMP$=TEMP$+"11"
  117. 1370   IF MID$(T8$,4,3)="Dec" THEN TEMP$=TEMP$+"12"
  118. 1380   TEMP$=TEMP$+LEFT$(T8$,2)  'add day
  119. 1390   IDX$(N.ACT) = T2$+" "+T3$+TEMP$
  120. 1400   N.ACT = N.ACT + 1
  121. 1410  NEXT I
  122. 1420  N.ACT = N.ACT - 1
  123. 1430  LOCATE 23,1 : PRINT SPACE$(79)
  124. 1440  REM Sort the index into ascending sequence
  125. 1450  CLS
  126. 1460  FOR I = 1 TO 6
  127. 1470   B(I) = B(I-1)*4+1
  128. 1480   IF B(I) <= N.ACT/2 THEN K1 = I
  129. 1490  NEXT I
  130. 1500  B(K1) = INT(N.ACT/5) +1
  131. 1510  B(1) = 1
  132. 1520  LOCATE 21,1 : PRINT "Total Records:";N.ACT;
  133. 1530  FOR I = K1 TO 1 STEP -1
  134. 1540   LOCATE 23,1 : PRINT "Sorting Group:";I
  135. 1550   K1 = B(I)
  136. 1560   FOR J = K1 TO N.ACT
  137. 1570    LOCATE 23,20 : PRINT "J:";J;
  138. 1580    K2$ = IDX$(J) : K3 = WHERE(J)
  139. 1590    FOR K = J-K1 TO 0 STEP -K1
  140. 1600     LOCATE 23,30 : PRINT "K:";K,"Freespace:";FRE(0)
  141. 1610     IF K2$ >= IDX$(K) THEN 1640
  142. 1620     IDX$(K+K1) = IDX$(K) : WHERE(K+K1) = WHERE(K)
  143. 1630    NEXT K
  144. 1640    IDX$(K+K1) = K2$ : WHERE(K+K1) = K3
  145. 1650   NEXT J
  146. 1660  NEXT I
  147. 1670  LOCATE 23,1 : PRINT SPACE$(79)
  148. 1680  LOCATE 23,1 : PRINT "Printing the Alphabetical List"
  149. 1690  GOSUB 1710
  150. 1700  GOTO 1760
  151. 1710  LPRINT "     Alphabetic Listing of the Persons File   ";DATE$;"  ";TIME$
  152. 1720  LPRINT
  153. 1730  LPRINT "  REC    SURNAME             GIVEN-NAMES";TAB(60);"BIRTHDATE"
  154. 1740  LPRINT "  ---    -------             -----------";TAB(60);"---------"
  155. 1750  RETURN
  156. 1760  REM Read all records, and print the actual ones
  157. 1770  K = 0
  158. 1780  CLS
  159. 1790  LOCATE 21,1 : PRINT "There are";N.ACT;"records."
  160. 1800  FOR I = 1 TO N.ACT
  161. 1810   GET #1, ABS(WHERE(I))
  162. 1820   LOCATE 23,1 : PRINT "Printing Record:"; I, "Freespace:";FRE(0)
  163. 1830   REM Print the information in Alphabetical Order.
  164. 1840   T1 = CVS(F1$)
  165. 1850   IF T1 < 1 THEN 1930
  166. 1860   K = K + 1
  167. 1870   T2$ = F2$
  168. 1880   T3$ = F3$
  169. 1890   T8$ = F8$
  170. 1900   IF K MOD 55 = 0 THEN LPRINT CHR$(12);: GOSUB 1710
  171. 1910   LPRINT USING "#####";T1,
  172. 1920   LPRINT TAB(10); T2$; T3$; TAB(60); T8$
  173. 1930  NEXT I
  174. 1940  CLOSE #1
  175. 1950  CLS : LOCATE 21,1
  176. 1960  PRINT "End of Program"
  177. 1970  LPRINT CHR$(12);
  178. 1980  RUN "a:menu"
  179.